home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH13 / SRC / RRAY1.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-08  |  28.0 KB  |  872 lines

  1. VERSION 4.00
  2. Begin VB.Form RayForm 
  3.    Appearance      =   0  'Flat
  4.    Caption         =   "RRay1"
  5.    ClientHeight    =   4245
  6.    ClientLeft      =   1905
  7.    ClientTop       =   1320
  8.    ClientWidth     =   6030
  9.    BeginProperty Font 
  10.       name            =   "MS Sans Serif"
  11.       charset         =   0
  12.       weight          =   700
  13.       size            =   8.25
  14.       underline       =   0   'False
  15.       italic          =   0   'False
  16.       strikethrough   =   0   'False
  17.    EndProperty
  18.    ForeColor       =   &H80000008&
  19.    Height          =   4935
  20.    KeyPreview      =   -1  'True
  21.    Left            =   1845
  22.    LinkTopic       =   "Form1"
  23.    ScaleHeight     =   283
  24.    ScaleMode       =   3  'Pixel
  25.    ScaleWidth      =   402
  26.    Top             =   690
  27.    Width           =   6150
  28.    Begin VB.TextBox DepthText 
  29.       BeginProperty Font 
  30.          name            =   "MS Sans Serif"
  31.          charset         =   0
  32.          weight          =   700
  33.          size            =   8.25
  34.          underline       =   0   'False
  35.          italic          =   0   'False
  36.          strikethrough   =   0   'False
  37.       EndProperty
  38.       Height          =   285
  39.       Left            =   840
  40.       TabIndex        =   17
  41.       Text            =   "1"
  42.       Top             =   3120
  43.       Width           =   855
  44.    End
  45.    Begin VB.OptionButton Scene 
  46.       Caption         =   "Sphere + Checks"
  47.       BeginProperty Font 
  48.          name            =   "MS Sans Serif"
  49.          charset         =   0
  50.          weight          =   700
  51.          size            =   8.25
  52.          underline       =   0   'False
  53.          italic          =   0   'False
  54.          strikethrough   =   0   'False
  55.       EndProperty
  56.       Height          =   255
  57.       Index           =   3
  58.       Left            =   0
  59.       TabIndex        =   16
  60.       Top             =   1080
  61.       Width           =   2025
  62.    End
  63.    Begin VB.OptionButton Scene 
  64.       Caption         =   "Dumbell Over Plane"
  65.       BeginProperty Font 
  66.          name            =   "MS Sans Serif"
  67.          charset         =   0
  68.          weight          =   700
  69.          size            =   8.25
  70.          underline       =   0   'False
  71.          italic          =   0   'False
  72.          strikethrough   =   0   'False
  73.       EndProperty
  74.       Height          =   255
  75.       Index           =   2
  76.       Left            =   0
  77.       TabIndex        =   15
  78.       Top             =   720
  79.       Width           =   2025
  80.    End
  81.    Begin VB.OptionButton Scene 
  82.       Caption         =   "Sphere + Squares"
  83.       BeginProperty Font 
  84.          name            =   "MS Sans Serif"
  85.          charset         =   0
  86.          weight          =   700
  87.          size            =   8.25
  88.          underline       =   0   'False
  89.          italic          =   0   'False
  90.          strikethrough   =   0   'False
  91.       EndProperty
  92.       Height          =   255
  93.       Index           =   1
  94.       Left            =   0
  95.       TabIndex        =   14
  96.       Top             =   360
  97.       Width           =   2025
  98.    End
  99.    Begin VB.OptionButton Scene 
  100.       Caption         =   "Spheres Over Plane"
  101.       BeginProperty Font 
  102.          name            =   "MS Sans Serif"
  103.          charset         =   0
  104.          weight          =   700
  105.          size            =   8.25
  106.          underline       =   0   'False
  107.          italic          =   0   'False
  108.          strikethrough   =   0   'False
  109.       EndProperty
  110.       Height          =   255
  111.       Index           =   0
  112.       Left            =   0
  113.       TabIndex        =   13
  114.       Top             =   0
  115.       Value           =   -1  'True
  116.       Width           =   2025
  117.    End
  118.    Begin VB.TextBox StepText 
  119.       BeginProperty Font 
  120.          name            =   "MS Sans Serif"
  121.          charset         =   0
  122.          weight          =   700
  123.          size            =   8.25
  124.          underline       =   0   'False
  125.          italic          =   0   'False
  126.          strikethrough   =   0   'False
  127.       EndProperty
  128.       Height          =   285
  129.       Left            =   840
  130.       TabIndex        =   11
  131.       Text            =   "4"
  132.       Top             =   3480
  133.       Width           =   855
  134.    End
  135.    Begin VB.CommandButton CmdGo 
  136.       Caption         =   "Go"
  137.       Default         =   -1  'True
  138.       BeginProperty Font 
  139.          name            =   "MS Sans Serif"
  140.          charset         =   0
  141.          weight          =   700
  142.          size            =   8.25
  143.          underline       =   0   'False
  144.          italic          =   0   'False
  145.          strikethrough   =   0   'False
  146.       EndProperty
  147.       Height          =   375
  148.       Left            =   600
  149.       TabIndex        =   10
  150.       Top             =   3840
  151.       Width           =   1095
  152.    End
  153.    Begin VB.TextBox KdistText 
  154.       BeginProperty Font 
  155.          name            =   "MS Sans Serif"
  156.          charset         =   0
  157.          weight          =   700
  158.          size            =   8.25
  159.          underline       =   0   'False
  160.          italic          =   0   'False
  161.          strikethrough   =   0   'False
  162.       EndProperty
  163.       Height          =   285
  164.       Left            =   840
  165.       TabIndex        =   7
  166.       Text            =   "-850"
  167.       Top             =   2640
  168.       Width           =   855
  169.    End
  170.    Begin VB.TextBox PhiText 
  171.       BeginProperty Font 
  172.          name            =   "MS Sans Serif"
  173.          charset         =   0
  174.          weight          =   700
  175.          size            =   8.25
  176.          underline       =   0   'False
  177.          italic          =   0   'False
  178.          strikethrough   =   0   'False
  179.       EndProperty
  180.       Height          =   285
  181.       Left            =   840
  182.       TabIndex        =   6
  183.       Text            =   "-0.4713"
  184.       Top             =   2160
  185.       Width           =   855
  186.    End
  187.    Begin VB.TextBox ThetaText 
  188.       BeginProperty Font 
  189.          name            =   "MS Sans Serif"
  190.          charset         =   0
  191.          weight          =   700
  192.          size            =   8.25
  193.          underline       =   0   'False
  194.          italic          =   0   'False
  195.          strikethrough   =   0   'False
  196.       EndProperty
  197.       Height          =   285
  198.       Left            =   840
  199.       TabIndex        =   4
  200.       Text            =   "0.6275"
  201.       Top             =   1800
  202.       Width           =   855
  203.    End
  204.    Begin VB.TextBox RText 
  205.       BeginProperty Font 
  206.          name            =   "MS Sans Serif"
  207.          charset         =   0
  208.          weight          =   700
  209.          size            =   8.25
  210.          underline       =   0   'False
  211.          italic          =   0   'False
  212.          strikethrough   =   0   'False
  213.       EndProperty
  214.       Height          =   285
  215.       Left            =   840
  216.       TabIndex        =   2
  217.       Text            =   "1000"
  218.       Top             =   1440
  219.       Width           =   855
  220.    End
  221.    Begin VB.PictureBox Pict 
  222.       AutoRedraw      =   -1  'True
  223.       BackColor       =   &H00FFFF80&
  224.       BeginProperty Font 
  225.          name            =   "MS Sans Serif"
  226.          charset         =   0
  227.          weight          =   700
  228.          size            =   8.25
  229.          underline       =   0   'False
  230.          italic          =   0   'False
  231.          strikethrough   =   0   'False
  232.       EndProperty
  233.       Height          =   3975
  234.       Left            =   2040
  235.       Picture         =   "RRay1.frx":0000
  236.       ScaleHeight     =   261
  237.       ScaleMode       =   3  'Pixel
  238.       ScaleWidth      =   261
  239.       TabIndex        =   0
  240.       Top             =   0
  241.       Width           =   3975
  242.    End
  243.    Begin VB.Label Label1 
  244.       Caption         =   "Depth"
  245.       BeginProperty Font 
  246.          name            =   "MS Sans Serif"
  247.          charset         =   0
  248.          weight          =   700
  249.          size            =   8.25
  250.          underline       =   0   'False
  251.          italic          =   0   'False
  252.          strikethrough   =   0   'False
  253.       EndProperty
  254.       Height          =   255
  255.       Index           =   3
  256.       Left            =   240
  257.       TabIndex        =   18
  258.       Top             =   3120
  259.       Width           =   615
  260.    End
  261.    Begin VB.Label Label1 
  262.       Caption         =   "Step"
  263.       BeginProperty Font 
  264.          name            =   "MS Sans Serif"
  265.          charset         =   0
  266.          weight          =   700
  267.          size            =   8.25
  268.          underline       =   0   'False
  269.          italic          =   0   'False
  270.          strikethrough   =   0   'False
  271.       EndProperty
  272.       Height          =   255
  273.       Index           =   13
  274.       Left            =   240
  275.       TabIndex        =   12
  276.       Top             =   3480
  277.       Width           =   615
  278.    End
  279.    Begin VB.Label Label1 
  280.       Caption         =   "dist"
  281.       BeginProperty Font 
  282.          name            =   "MS Sans Serif"
  283.          charset         =   0
  284.          weight          =   700
  285.          size            =   8.25
  286.          underline       =   0   'False
  287.          italic          =   0   'False
  288.          strikethrough   =   0   'False
  289.       EndProperty
  290.       Height          =   255
  291.       Index           =   8
  292.       Left            =   360
  293.       TabIndex        =   9
  294.       Top             =   2760
  295.       Width           =   375
  296.    End
  297.    Begin VB.Label Label1 
  298.       Caption         =   "k"
  299.       BeginProperty Font 
  300.          name            =   "MS Sans Serif"
  301.          charset         =   0
  302.          weight          =   700
  303.          size            =   8.25
  304.          underline       =   0   'False
  305.          italic          =   0   'False
  306.          strikethrough   =   0   'False
  307.       EndProperty
  308.       Height          =   255
  309.       Index           =   6
  310.       Left            =   240
  311.       TabIndex        =   8
  312.       Top             =   2640
  313.       Width           =   135
  314.    End
  315.    Begin MSComDlg.CommonDialog LoadDialog 
  316.       Left            =   0
  317.       Top             =   3960
  318.       _Version        =   65536
  319.       _ExtentX        =   847
  320.       _ExtentY        =   847
  321.       _StockProps     =   0
  322.       CancelError     =   -1  'True
  323.    End
  324.    Begin VB.Label Label1 
  325.       Caption         =   "Phi"
  326.       BeginProperty Font 
  327.          name            =   "MS Sans Serif"
  328.          charset         =   0
  329.          weight          =   700
  330.          size            =   8.25
  331.          underline       =   0   'False
  332.          italic          =   0   'False
  333.          strikethrough   =   0   'False
  334.       EndProperty
  335.       Height          =   255
  336.       Index           =   2
  337.       Left            =   240
  338.       TabIndex        =   5
  339.       Top             =   2160
  340.       Width           =   375
  341.    End
  342.    Begin VB.Label Label1 
  343.       Caption         =   "Theta"
  344.       BeginProperty Font 
  345.          name            =   "MS Sans Serif"
  346.          charset         =   0
  347.          weight          =   700
  348.          size            =   8.25
  349.          underline       =   0   'False
  350.          italic          =   0   'False
  351.          strikethrough   =   0   'False
  352.       EndProperty
  353.       Height          =   255
  354.       Index           =   1
  355.       Left            =   240
  356.       TabIndex        =   3
  357.       Top             =   1800
  358.       Width           =   495
  359.    End
  360.    Begin VB.Label Label1 
  361.       Caption         =   "R"
  362.       BeginProperty Font 
  363.          name            =   "MS Sans Serif"
  364.          charset         =   0
  365.          weight          =   700
  366.          size            =   8.25
  367.          underline       =   0   'False
  368.          italic          =   0   'False
  369.          strikethrough   =   0   'False
  370.       EndProperty
  371.       Height          =   255
  372.       Index           =   0
  373.       Left            =   240
  374.       TabIndex        =   1
  375.       Top             =   1440
  376.       Width           =   255
  377.    End
  378.    Begin VB.Menu mnuFile 
  379.       Caption         =   "&File"
  380.       Begin VB.Menu mnuFileSaveBitmap 
  381.          Caption         =   "&Save Bitmap..."
  382.          Shortcut        =   ^S
  383.       End
  384.       Begin VB.Menu mnuFileSep 
  385.          Caption         =   "-"
  386.       End
  387.       Begin VB.Menu mnuFileExit 
  388.          Caption         =   "E&xit"
  389.       End
  390.    End
  391. Attribute VB_Name = "RayForm"
  392. Attribute VB_Creatable = False
  393. Attribute VB_Exposed = False
  394. Option Explicit
  395. Dim SysPalSize As Integer
  396. Dim NumStaticColors As Integer
  397. Dim StaticColor1 As Integer
  398. Dim StaticColor2 As Integer
  399. Dim syspal(0 To 255) As PALETTEENTRY
  400. ' Location of viewing eye.
  401. Dim EyeR As Single
  402. Dim EyeTheta As Single
  403. Dim EyePhi As Single
  404. Const dtheta = PI / 20
  405. Const Dphi = PI / 20
  406. Const dR = 1
  407. ' Location of focus point.
  408. Const FocusX = 0#
  409. Const FocusY = 0#
  410. Const FocusZ = 0#
  411. Dim Projector(1 To 4, 1 To 4) As Single
  412. Dim Running As Boolean
  413. Dim SceneChoice As Integer
  414. ' ************************************************
  415. ' Halt immediately in case we're in the middle of
  416. ' ray tracing.
  417. ' ************************************************
  418. Private Sub Form_Unload(Cancel As Integer)
  419.     End
  420. End Sub
  421. ' ************************************************
  422. ' Create the objects in the scene.
  423. ' ************************************************
  424. Sub CreateData()
  425. Dim obj As Object
  426. Dim S As Single
  427. Dim i As Integer
  428. Dim j As Integer
  429. Dim j1 As Integer
  430.     Set Objects = New Collection
  431.     Select Case SceneChoice
  432.         Case 0  ' 2 Spheres + Plane.
  433.             ' Sphere of radius 40 at (-40, -40, 0).
  434.             Set obj = New ObjSphere
  435.             Objects.Add obj
  436.             obj.Initialize 40, -40, -40, 0
  437.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  438.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  439.             obj.SetSpec 20, 0.35        ' Specular.
  440.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  441.         
  442.             ' Sphere of radius 40 at (40, -40, 0).
  443.             Set obj = New ObjSphere
  444.             Objects.Add obj
  445.             obj.Initialize 40, 40, -40, 0
  446.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  447.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  448.             obj.SetSpec 20, 0.35        ' Specular.
  449.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  450.         
  451.             ' X-Z plane.
  452.             Set obj = New ObjPlane
  453.             Objects.Add obj
  454.             obj.Initialize 0, 0, 0, 0, -1, 0
  455.             obj.SetKd 0.3, 0.3, 0.3     ' Diffuse.
  456.             obj.SetKa 0.2, 0.2, 0.2     ' Ambient.
  457.             obj.SetSpec 20, 0.35        ' Specular.
  458.             obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  459.         Case 1  ' Sphere + Square.
  460.             ' Sphere of radius 40 at (0, 0, 0).
  461.             Set obj = New ObjSphere
  462.             Objects.Add obj
  463.             obj.Initialize 40, 0, 0, 0
  464.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  465.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  466.             obj.SetSpec 20, 0.35        ' Specular.
  467.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  468.             S = 75
  469.             ' Square in the plane x = -s with
  470.             ' side length 2 * s.
  471.             Set obj = New ObjPolygon
  472.             Objects.Add obj
  473.             obj.AddPoint _
  474.                 -S, S, S, _
  475.                 -S, -S, S, _
  476.                 -S, -S, -S, _
  477.                 -S, S, -S
  478.             obj.DefinePlane
  479.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  480.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  481.             obj.SetSpec 20, 0.35        ' Specular.
  482.             obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  483.             ' Square in the plane z = -s with
  484.             ' side length 2 * s.
  485.             Set obj = New ObjPolygon
  486.             Objects.Add obj
  487.             obj.AddPoint _
  488.                 S, S, -S, _
  489.                 -S, S, -S, _
  490.                 -S, -S, -S, _
  491.                 S, -S, -S
  492.             obj.DefinePlane
  493.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  494.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  495.             obj.SetSpec 20, 0.35        ' Specular.
  496.             obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  497.         Case 2  ' Dumbell above plane.
  498.             ' Sphere of radius 30 at (-100, -30, 0).
  499.             Set obj = New ObjSphere
  500.             Objects.Add obj
  501.             obj.Initialize 30, -100, -30, 0
  502.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  503.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  504.             obj.SetSpec 20, 0.35        ' Specular.
  505.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  506.             ' Sphere of radius 30 at (100, -30, 0).
  507.             Set obj = New ObjSphere
  508.             Objects.Add obj
  509.             obj.Initialize 30, 100, -30, 0
  510.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  511.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  512.             obj.SetSpec 20, 0.35        ' Specular.
  513.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  514.             ' Cylinder of radius 15 between
  515.             ' (-100, -30, 0) and (100, -30, 0).
  516.             Set obj = New ObjCylinder
  517.             Objects.Add obj
  518.             obj.Initialize 15, -100, -30, 0, 100, -30, 0
  519.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  520.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  521.             obj.SetSpec 20, 0.35        ' Specular.
  522.             obj.SetKr 0.2, 0.2, 0.2     ' Reflected.
  523.             ' X-Z plane.
  524.             Set obj = New ObjPlane
  525.             Objects.Add obj
  526.             obj.Initialize 0, 0, 0, 0, -1, 0
  527.             obj.SetKd 0.3, 0.3, 0.3     ' Diffuse.
  528.             obj.SetKa 0.2, 0.2, 0.2     ' Ambient.
  529.             obj.SetSpec 20, 0.35        ' Specular.
  530.             obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  531.         
  532.         Case 3  ' Spheres + Cylinders.
  533.             
  534.             ' Sphere of radius 50 at (0, -60, 0).
  535.             Set obj = New ObjSphere
  536.             Objects.Add obj
  537.             obj.Initialize 50, 0, -60, 0
  538.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  539.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  540.             obj.SetSpec 20, 0.35        ' Specular.
  541.             obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  542.             ' Make a plane of squares.
  543.             S = 40
  544.             For i = -3 To 3
  545.                 If i Mod 2 = 0 Then
  546.                     j1 = -2
  547.                 Else
  548.                     j1 = -3
  549.                 End If
  550.                 For j = j1 To 3 Step 2
  551.                     ' Make a square.
  552.                     Set obj = New ObjPolygon
  553.                     Objects.Add obj
  554.                     obj.AddPoint _
  555.                         i * S, 0, j * S, _
  556.                         i * S + S, 0, j * S, _
  557.                         i * S + S, 0, j * S + S, _
  558.                         i * S, 0, j * S + S
  559.                     obj.DefinePlane
  560.                     obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  561.                     obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  562.                     obj.SetSpec 20, 0.35        ' Specular.
  563.                     obj.SetKr 0.5, 0.5, 0.5     ' Reflected.
  564.                 Next j
  565.             Next i
  566.     End Select
  567. End Sub
  568. ' *******************************************************
  569. ' Project and draw.
  570. ' *******************************************************
  571. Private Sub DrawData(pic As Object)
  572. Dim Projector(1 To 4, 1 To 4) As Single
  573. Dim obj As Object
  574. Dim factor As Single
  575.     ' Get the current eye location.
  576.     EyeR = CSng(RText.Text)
  577.     EyeTheta = CSng(ThetaText.Text)
  578.     EyePhi = CSng(PhiText.Text)
  579.     ' Create the data.
  580.     CreateData
  581.     ' Get constants for the surfaces.
  582.     LightKdist = CSng(KdistText.Text)
  583.     ' Create a background color.
  584.     BackR = 0
  585.     BackG = 0
  586.     BackB = 0
  587.     ' Fill with another color so we can see progress.
  588.     pic.Line (pic.ScaleLeft, pic.ScaleTop)- _
  589.         Step(pic.ScaleWidth, pic.ScaleHeight), _
  590.         RGB(0, 0, &H80), BF
  591.     ' Rotate the eye onto the Z axis.
  592.     m3PProject Projector, m3Parallel, _
  593.         EyeR, EyePhi, EyeTheta, _
  594.         FocusX, FocusY, FocusZ, _
  595.         0, 1, 0
  596.     ' Transform the objects.
  597.     For Each obj In Objects
  598.         obj.Apply Projector
  599.     Next obj
  600.     ' Transform the light source.
  601.     m3Apply LightSource.coord, Projector, LightSource.trans
  602.     ' Adjust the incident light values.
  603.     factor = _
  604.         Sqr(LightSource.trans(1) * LightSource.trans(1) + _
  605.             LightSource.trans(2) * LightSource.trans(2) + _
  606.             LightSource.trans(3) * LightSource.trans(3)) _
  607.             + LightKdist + 4
  608.     LightIir = 255 * factor
  609.     LightIig = 255 * factor
  610.     LightIib = 255 * factor
  611.     ' Display the data.
  612.     RayTrace pic, CInt(StepText.Text)
  613.     ' Display the viewing parameters.
  614.     ShowViewingParameters
  615. End Sub
  616. ' ************************************************
  617. ' Start ray tracing for this picture box.
  618. ' ************************************************
  619. Sub RayTrace(pic As PictureBox, skip As Integer)
  620. Dim x As Integer
  621. Dim y As Integer
  622. Dim xmax As Integer
  623. Dim ymax As Integer
  624. Dim xoff As Integer
  625. Dim yoff As Integer
  626. Dim r As Integer
  627. Dim G As Integer
  628. Dim B As Integer
  629. Dim max_depth As Integer
  630.     ' Get the transformed coordinates of the eye.
  631.     EyeX = 0
  632.     EyeY = 0
  633.     EyeZ = EyeR
  634.     ' Get the maximum depth of recursion.
  635.     max_depth = CInt(DepthText.Text)
  636.     xoff = pic.ScaleWidth / 2
  637.     yoff = pic.ScaleHeight / 2
  638.     xmax = pic.ScaleLeft + pic.ScaleWidth - 1
  639.     ymax = pic.ScaleTop + pic.ScaleHeight - 1
  640.     For y = pic.ScaleTop To ymax Step skip
  641.         For x = pic.ScaleLeft To xmax Step skip
  642.             ' Calculate the value of pixel (x, y).
  643.             ' After transformation the eye is
  644.             ' at (0, 0, EyeR) and the plane of
  645.             ' projection lies in the X-Y plane.
  646.             TraceRay max_depth, 0, 0, EyeR, _
  647.                 CSng(x) - xoff, _
  648.                 CSng(y) - yoff, _
  649.                 -EyeR, _
  650.                 r, G, B
  651.                 
  652.             ' Draw the pixel.
  653.             If skip < 2 Then
  654.                 pic.PSet (x, y), RGB(r, G, B)
  655.             Else
  656.                 pic.Line (x, y)- _
  657.                     Step(skip - 1, skip - 1), _
  658.                     RGB(r, G, B), BF
  659.             End If
  660.         Next x
  661.         
  662.         ' Let the user see what's going on.
  663.         pic.Refresh
  664.         
  665.         ' If the Stop button was pressed, stop.
  666.         DoEvents
  667.         If Not Running Then Exit Sub
  668.     Next y
  669. End Sub
  670. Sub ShowViewingParameters()
  671.     RText.Text = Format$(EyeR, "0")
  672.     ThetaText.Text = Format$(EyeTheta, "0.0000")
  673.     PhiText.Text = Format$(EyePhi, "0.0000")
  674.     RText.Refresh
  675.     ThetaText.Refresh
  676.     PhiText.Refresh
  677. End Sub
  678. ' ************************************************
  679. ' Do the ray tracing.
  680. ' ************************************************
  681. Private Sub CmdGo_Click()
  682.     If Running Then
  683.         Running = False
  684.         CmdGo.Caption = "Stopped"
  685.         CmdGo.Enabled = False
  686.         DoEvents
  687.     Else
  688.         Running = True
  689.         CmdGo.Caption = "Stop"
  690.         MousePointer = vbHourglass
  691.         DoEvents
  692.         
  693.         DrawData Pict
  694.         
  695.         MousePointer = vbDefault
  696.         CmdGo.Enabled = True
  697.         CmdGo.Caption = "Go"
  698.         Running = False
  699.         Beep
  700.     End If
  701. End Sub
  702. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  703.     Select Case KeyCode
  704.         Case vbKeyLeft
  705.             EyeTheta = EyeTheta - dtheta
  706.         
  707.         Case vbKeyRight
  708.             EyeTheta = EyeTheta + dtheta
  709.         
  710.         Case vbKeyUp
  711.             EyePhi = EyePhi - Dphi
  712.         
  713.         Case vbKeyDown
  714.             EyePhi = EyePhi + Dphi
  715.                 
  716.         Case Else
  717.             Exit Sub
  718.     End Select
  719.     ShowViewingParameters
  720. End Sub
  721. Private Sub Form_KeyPress(KeyAscii As Integer)
  722.     Select Case KeyAscii
  723.         Case Asc("+")
  724.             EyeR = EyeR + dR
  725.         
  726.         Case Asc("-")
  727.             EyeR = EyeR - dR
  728.         
  729.         Case Else
  730.             Exit Sub
  731.     End Select
  732.     ShowViewingParameters
  733. End Sub
  734. Private Sub Form_Load()
  735.     ' Make sure the screen supports palettes.
  736.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  737.         Beep
  738.         MsgBox "This monitor does not support palettes.", _
  739.             vbCritical
  740.         End
  741.     End If
  742.     ' Get system palette size and # static colors.
  743.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  744.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  745.     StaticColor1 = NumStaticColors \ 2 - 1
  746.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  747.     ' Fill the picture's palette with grays.
  748.     MatchGrayPalette Pict
  749.     Pict.Cls
  750.     ' Initialize lighting constants.
  751.     LightSource.coord(1) = 100
  752.     LightSource.coord(2) = -500
  753.     LightSource.coord(3) = 1000
  754.     LightSource.coord(4) = 1
  755.     LightIar = 128
  756.     LightIag = 128
  757.     LightIab = 128
  758.     ' Initialize the eye position.
  759.     EyeR = CSng(RText.Text)
  760.     EyeTheta = CSng(ThetaText.Text)
  761.     EyePhi = CSng(PhiText.Text)
  762.     ' Initialize the projection transformation.
  763.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  764. End Sub
  765. ' ***********************************************
  766. ' Load the control's palette so the non-static
  767. ' colors are grays. Map the logical palette to
  768. ' match the system palette. Convert the image to
  769. ' use the non-static grays.
  770. ' Leave new system palette entries in SysPal().
  771. ' ***********************************************
  772. Sub MatchGrayPalette(pic As Control)
  773. Dim origpal(0 To 255) As PALETTEENTRY
  774. Dim wid As Long
  775. Dim hgt As Long
  776. Dim bytes() As Byte
  777. Dim i As Integer
  778. Dim bm As BITMAP
  779. Dim hbm As Integer
  780. Dim status As Long
  781. Dim x As Integer
  782. Dim y As Integer
  783. Dim gray As Single
  784. Dim dgray As Single
  785. Dim C As Integer
  786. Dim clr As Integer
  787. Dim logpal As Long
  788.     ' Make sure pic has the foreground palette.
  789.     pic.ZOrder
  790.     status = RealizePalette(pic.hdc)
  791.     DoEvents
  792.     ' Get the system palette entries.
  793.     status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(0))
  794.         
  795.     ' Get the image pixels.
  796.     hbm = pic.Image
  797.     status = GetObject(hbm, BITMAP_SIZE, bm)
  798.     wid = bm.bmWidthBytes
  799.     hgt = bm.bmHeight
  800.     ReDim bytes(1 To wid, 1 To hgt)
  801.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  802.     ' Make the logical palette as big as possible.
  803.     logpal = pic.Picture.hPal
  804.     If ResizePalette(logpal, SysPalSize) = 0 Then
  805.         Beep
  806.         MsgBox "Error resizing logical palette.", _
  807.             vbExclamation
  808.         Exit Sub
  809.     End If
  810.     ' Blank the non-static colors.
  811.     For i = 0 To StaticColor1
  812.         syspal(i) = origpal(i)
  813.     Next i
  814.     For i = StaticColor1 + 1 To StaticColor2 - 1
  815.         With syspal(i)
  816.             .peRed = 0
  817.             .peGreen = 0
  818.             .peBlue = 0
  819.             .peFlags = PC_NOCOLLAPSE
  820.         End With
  821.     Next i
  822.     For i = StaticColor2 To 255
  823.         syspal(i) = origpal(i)
  824.     Next i
  825.     status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(0))
  826.     ' Insert the non-static grays.
  827.     gray = 0
  828.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  829.     For i = StaticColor1 + 1 To StaticColor2 - 1
  830.         C = gray
  831.         gray = gray + dgray
  832.         With syspal(i)
  833.             .peRed = C
  834.             .peGreen = C
  835.             .peBlue = C
  836.         End With
  837.     Next i
  838.     status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1))
  839.     ' Realize the gray palette.
  840.     status = RealizePalette(pic.hdc)
  841.     pic.Refresh
  842. End Sub
  843. Private Sub mnuFileExit_Click()
  844.     Unload Me
  845. End Sub
  846. Private Sub mnuFileSaveBitmap_Click()
  847. Dim fname As String
  848.     ' Allow the user to pick a file.
  849.     On Error Resume Next
  850.     LoadDialog.filename = "*.BMP"
  851.     LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  852.     LoadDialog.ShowSave
  853.     If Err.Number = cdlCancel Then
  854.         Unload LoadDialog
  855.         Exit Sub
  856.     ElseIf Err.Number <> 0 Then
  857.         Unload LoadDialog
  858.         Beep
  859.         MsgBox "Error selecting file.", , vbExclamation
  860.         Exit Sub
  861.     End If
  862.     On Error GoTo 0
  863.     fname = LoadDialog.filename
  864.     SavePicture Pict.Image, fname
  865. End Sub
  866. ' ************************************************
  867. ' Select this choice.
  868. ' ************************************************
  869. Private Sub Scene_Click(index As Integer)
  870.     SceneChoice = index
  871. End Sub
  872.